      subroutine vtoctov(nvtx, ijkvtx, iwid, jwid, kwid, ibp2, jbp2, kbp2, &
         istep, sdlt, cdlt, wkl, wkr, wkf, wke, phibc, bxv, byv, bzv, a, b, c, &
         periodicx)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
      use modify_com_M

!...Translated by Pacific-Sierra Research 77to90  4.3E  14:13:36   8/20/02
!...Switches: -yf -x1
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: nvtx
      integer  :: iwid
      integer  :: jwid
      integer  :: kwid
      integer  :: ibp2
      integer  :: jbp2
      integer  :: kbp2
      integer , intent(in) :: istep
      real(double)  :: sdlt
      real(double)  :: cdlt
      real(double)  :: wkl
      real(double)  :: wkr
      real(double)  :: wkf
      real(double)  :: wke
      real(double)  :: phibc
      logical  :: periodicx
      integer , intent(in) :: ijkvtx(*)
      real(double)  :: bxv(*)
      real(double)  :: byv(*)
      real(double)  :: bzv(*)
      real(double)  :: a(*)
      real(double)  :: b(*)
      real(double)  :: c(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: ibp1, jbp1, kbp1, ijk, iter, i, j, k, n
      real(double) :: wk
!-----------------------------------------------
!
      ibp1 = ibp2 - 1
      jbp1 = jbp2 - 1
      kbp1 = kbp2 - 1
!
      a(:ibp2*jbp2*kbp2) = 0.
      b(:ibp2*jbp2*kbp2) = 0.
      c(:ibp2*jbp2*kbp2) = 0.
!
      do iter = 1, istep
!
!      call bcsmooth(ibp2,jbp2,kbp2,2.,bxv,periodicx)
!      call bcsmooth(ibp2,jbp2,kbp2,2.,byv,periodicx)
!      call bcsmooth(ibp2,jbp2,kbp2,2.,bzv,periodicx)
!
         do i = 2, ibp1
            do j = 2, jbp1
!dir$ ivdep
!
               a(kwid+1+(i-1)*iwid+(j-1)*jwid:(kbp1-1)*kwid+1+(i-1)*iwid+(j-1)*&
                  jwid:kwid) = (bxv(kwid+1+i*iwid+(j-1)*jwid:(kbp1-1)*kwid+1+i*&
                  iwid+(j-1)*jwid:kwid)+bxv(1+i*iwid+j*jwid+kwid:(kbp1-1)*kwid+&
                  1+i*iwid+j*jwid:kwid)+bxv(kwid+1+(i-1)*iwid+j*jwid:(kbp1-1)*&
                  kwid+1+(i-1)*iwid+j*jwid:kwid)+bxv(kwid+1+(i-1)*iwid+(j-1)*&
                  jwid:(kbp1-1)*kwid+1+(i-1)*iwid+(j-1)*jwid:kwid)+bxv(kwid*2+1&
                  +i*iwid+(j-1)*jwid:kbp1*kwid+1+i*iwid+(j-1)*jwid:kwid)+bxv(&
                  kwid*2+1+i*iwid+j*jwid:kbp1*kwid+1+i*iwid+j*jwid:kwid)+bxv(&
                  kwid*2+1+(i-1)*iwid+j*jwid:kbp1*kwid+1+(i-1)*iwid+j*jwid:kwid&
                  )+bxv(kwid*2+1+(i-1)*iwid+(j-1)*jwid:kbp1*kwid+1+(i-1)*iwid+(&
                  j-1)*jwid:kwid))/8.
!
               b(kwid+1+(i-1)*iwid+(j-1)*jwid:(kbp1-1)*kwid+1+(i-1)*iwid+(j-1)*&
                  jwid:kwid) = (byv(kwid+1+i*iwid+(j-1)*jwid:(kbp1-1)*kwid+1+i*&
                  iwid+(j-1)*jwid:kwid)+byv(1+i*iwid+j*jwid+kwid:(kbp1-1)*kwid+&
                  1+i*iwid+j*jwid:kwid)+byv(kwid+1+(i-1)*iwid+j*jwid:(kbp1-1)*&
                  kwid+1+(i-1)*iwid+j*jwid:kwid)+byv(kwid+1+(i-1)*iwid+(j-1)*&
                  jwid:(kbp1-1)*kwid+1+(i-1)*iwid+(j-1)*jwid:kwid)+byv(kwid*2+1&
                  +i*iwid+(j-1)*jwid:kbp1*kwid+1+i*iwid+(j-1)*jwid:kwid)+byv(&
                  kwid*2+1+i*iwid+j*jwid:kbp1*kwid+1+i*iwid+j*jwid:kwid)+byv(&
                  kwid*2+1+(i-1)*iwid+j*jwid:kbp1*kwid+1+(i-1)*iwid+j*jwid:kwid&
                  )+byv(kwid*2+1+(i-1)*iwid+(j-1)*jwid:kbp1*kwid+1+(i-1)*iwid+(&
                  j-1)*jwid:kwid))/8.
!
               c(kwid+1+(i-1)*iwid+(j-1)*jwid:(kbp1-1)*kwid+1+(i-1)*iwid+(j-1)*&
                  jwid:kwid) = (bzv(kwid+1+i*iwid+(j-1)*jwid:(kbp1-1)*kwid+1+i*&
                  iwid+(j-1)*jwid:kwid)+bzv(1+i*iwid+j*jwid+kwid:(kbp1-1)*kwid+&
                  1+i*iwid+j*jwid:kwid)+bzv(kwid+1+(i-1)*iwid+j*jwid:(kbp1-1)*&
                  kwid+1+(i-1)*iwid+j*jwid:kwid)+bzv(kwid+1+(i-1)*iwid+(j-1)*&
                  jwid:(kbp1-1)*kwid+1+(i-1)*iwid+(j-1)*jwid:kwid)+bzv(kwid*2+1&
                  +i*iwid+(j-1)*jwid:kbp1*kwid+1+i*iwid+(j-1)*jwid:kwid)+bzv(&
                  kwid*2+1+i*iwid+j*jwid:kbp1*kwid+1+i*iwid+j*jwid:kwid)+bzv(&
                  kwid*2+1+(i-1)*iwid+j*jwid:kbp1*kwid+1+(i-1)*iwid+j*jwid:kwid&
                  )+bzv(kwid*2+1+(i-1)*iwid+(j-1)*jwid:kbp1*kwid+1+(i-1)*iwid+(&
                  j-1)*jwid:kwid))/8.
            end do
         end do
!
         wk = 1.
         call bcphi (ibp1, jbp1, kbp1, iwid, jwid, kwid, wk, wk, wk, wk, phibc&
            , a, periodicx)
         call bcphi (ibp1, jbp1, kbp1, iwid, jwid, kwid, wk, wk, wk, wk, phibc&
            , b, periodicx)
         call bcphi (ibp1, jbp1, kbp1, iwid, jwid, kwid, wk, wk, wk, wk, phibc&
            , c, periodicx)
!
!dir$ ivdep
         do n = 1, nvtx
!
            ijk = ijkvtx(n)
!
            bxv(ijk) = (a(ijk-iwid)+a(ijk-iwid-jwid)+a(ijk-jwid)+a(ijk)+a(ijk-&
               iwid-kwid)+a(ijk-iwid-jwid-kwid)+a(ijk-jwid-kwid)+a(ijk-kwid))/&
               8.
!
            byv(ijk) = (b(ijk-iwid)+b(ijk-iwid-jwid)+b(ijk-jwid)+b(ijk)+b(ijk-&
               iwid-kwid)+b(ijk-iwid-jwid-kwid)+b(ijk-jwid-kwid)+b(ijk-kwid))/&
               8.
!
            bzv(ijk) = (c(ijk-iwid)+c(ijk-iwid-jwid)+c(ijk-jwid)+c(ijk)+c(ijk-&
               iwid-kwid)+c(ijk-iwid-jwid-kwid)+c(ijk-jwid-kwid)+c(ijk-kwid))/&
               8.
!
         end do
!
         call bcsmooth (ibp2, jbp2, kbp2, 1., bxv, periodicx)
         call bcsmooth (ibp2, jbp2, kbp2, 1., byv, periodicx)
         call bcsmooth (ibp2, jbp2, kbp2, 1., bzv, periodicx)
!
      end do
!
      call bcperv (ibp2, jbp2, kbp2, iwid, jwid, kwid, sdlt, cdlt, bxv, byv, &
         bzv, periodicx)
!
!
      return
      end subroutine vtoctov




      subroutine ctovtoc(nvtx, ijkvtx, ncells, ijkcell, iwid, jwid, kwid, ibp1&
         , jbp1, kbp1, istep, phi, phibc, wk, a, periodicx)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
      use modify_com_M

!...Translated by Pacific-Sierra Research 77to90  4.3E  14:13:36   8/20/02
!...Switches: -yf -x1
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: nvtx
      integer , intent(in) :: ncells
      integer  :: iwid
      integer  :: jwid
      integer  :: kwid
      integer  :: ibp1
      integer  :: jbp1
      integer  :: kbp1
      integer , intent(in) :: istep
      real(double)  :: phibc
      real(double)  :: wk
      logical  :: periodicx
      integer , intent(in) :: ijkvtx(*)
      integer , intent(in) :: ijkcell(*)
      real(double)  :: phi(*)
      real(double)  :: a(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: ibp2, jbp2, kbp2, iter, n, ijk
!-----------------------------------------------
!
!     Assumes centre quanity defined everywhere including i=1,j=1,k=1
!     Create centre quantity defined  everywhere including i=1,j=1,k=1
!
!
      ibp2 = ibp1 + 1
      jbp2 = jbp1 + 1
      kbp2 = kbp1 + 1
!
      do iter = 1, istep
!
         wk = 1.
         call bcphi (ibp1, jbp1, kbp1, iwid, jwid, kwid, wk, wk, wk, wk, phibc&
            , phi, periodicx)
!
!      do 5 k=1,kbp1+1
!cdir$ ivdep
!      do 52 i=1,ibp1+1
!      ijkb=1+(i-1)*iwid+(k-1)*kwid
!      ijkt=1+(i-1)*iwid+jbp1*jwid+(k-1)*kwid
!      phi(ijkb)=0.
!      phi(ijkt)=0.
!   52 continue
!
!    5 continue
!
!dir$ ivdep
         do n = 1, nvtx
!
            ijk = ijkvtx(n)
!
            a(ijk) = (phi(ijk-iwid)+phi(ijk-iwid-jwid)+phi(ijk-jwid)+phi(ijk)+&
               phi(ijk-iwid-kwid)+phi(ijk-iwid-jwid-kwid)+phi(ijk-jwid-kwid)+&
               phi(ijk-kwid))/8.
!
         end do
!
         call bcsmooth (ibp2, jbp2, kbp2, 1., a, periodicx)
!
!      wsp=1.
!      call torusbc_scal(2,ibp2,2,jbp2,2,kbp2,iwid,jwid,kwid,
!     &     wsp,a,periodicx)
!
!dir$ ivdep
         do n = 1, ncells
!
            ijk = ijkcell(n)
!
            phi(ijk) = (a(ijk+iwid)+a(ijk+iwid+jwid)+a(ijk+jwid)+a(ijk)+a(ijk+&
               iwid+kwid)+a(ijk+iwid+jwid+kwid)+a(ijk+jwid+kwid)+a(ijk+kwid))/&
               8.
!
         end do
!
      end do
      return
      end subroutine ctovtoc



      subroutine bcsmooth(nxp, nyp, nzp, fact, a, periodicx)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
      use modify_com_M

!...Translated by Pacific-Sierra Research 77to90  4.3E  14:13:36   8/20/02
!...Switches: -yf -x1
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: nxp
      integer , intent(in) :: nyp
      integer , intent(in) :: nzp
      real(double) , intent(in) :: fact
      logical , intent(in) :: periodicx
      real(double) , intent(inout) :: a(nxp,nyp,*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: k, j, i
!-----------------------------------------------
!
!     x boundary
!
      if (.not.periodicx) then
         a(2,2:nyp,2:nzp) = fact*a(2,2:nyp,2:nzp)
         a(nxp,2:nyp,2:nzp) = fact*a(nxp,2:nyp,2:nzp)
      endif
!
!     y boundary
!
!      do i=2,nxp
!      do k=2,nzp
!      a(i,2,k)=fact*a(i,2,k)
!      a(i,nyp,k)=fact*a(i,nyp,k)
!      enddo
!      enddo
!
!     z boundary
!
      a(2:nxp,2:nyp,2) = fact*a(2:nxp,2:nyp,2)
      a(2:nxp,2:nyp,nzp) = fact*a(2:nxp,2:nyp,nzp)
!
      return
      end subroutine bcsmooth
